Amiga Tools 2/Amiga Tools 2.iso/tools/jade/lisp/disassembler.jl

Lisp/Scheme | 1995-03-09 | 5KB | 133 lines

;;;; disassembler.jl -- Disassembles compiled Lisp functions
;;;  Copyright (C) 1993, 1994 John Harper <[e-mail]>

;;; This file is part of Jade.

;;; Jade is free software; you can redistribute it and/or modify it
;;; under the terms of the GNU General Public License as published by
;;; the Free Software Foundation; either version 2, or (at your option)
;;; any later version.

;;; Jade is distributed in the hope that it will be useful, but
;;; WITHOUT ANY WARRANTY; without even the implied warranty of
;;; MERCHANTABILITY or FITNESS FOR A PARTICULAR PURPOSE.  See the
;;; GNU General Public License for more details.

;;; You should have received a copy of the GNU General Public License
;;; along with Jade; see the file COPYING.  If not, write to
;;; the Free Software Foundation, 675 Mass Ave, Cambridge, MA 02139, USA.

;; need this for the opcode constants
(require 'compiler)
(provide 'disassembler)

;; Lookup table of strings naming instructions
(defvar dis-opcode-vector
 [ nil nil nil nil nil nil nil nil     ; 0x00
   "call" nil nil nil nil nil nil nil
   "push" nil nil nil nil nil nil nil     ; 0x10
   "vrefc" nil nil nil nil nil nil nil
   "vsetc" nil nil nil nil nil nil nil     ; 0x20
   "list" nil nil nil nil nil nil nil
   "bind" nil nil nil nil nil nil nil     ; 0x30
   nil nil nil nil nil nil nil nil
   "vref" "vset" "fref" "fset" "init-bind" "unbind" "dup" "swap"    ; 0x40
   "pop" "push\tnil" "push\tt" "cons" "car" "cdr" "rplaca" "rplacd"
   "nth" "nthcdr" "aset" "aref" "length" "eval" "plus-2" "negate" "minus-2"    ; 0x50
   "product-2" "divide-2" "mod-2" "lognot" "not" "logior-2" "logand-2"
   "equal" "eq" "num-eq" "num-not-eq" "g-than" "ge-than" "l-than" "le-than"    ; 0x60
   "inc" "dec" "lsh" "zerop" "null" "atom" "consp" "listp"
   "numberp" "stringp" "vectorp" "catch-kludge" "throw" "unwind-pro" "un-unwind-pro" "fboundp"    ; 0x70
   "boundp" "symbolp" "get" "put" "error-pro" "signal" "return" "reverse"
   "nreverse" "assoc" "assq" "rassoc" "rassq" "last" "mapcar" "mapc" ; 0x80
   "member" "memq" "delete" "delq" "delete-if" "delete-if-not" "copy-sequence" "sequencep"
   "functionp" "special-form-p" "subrp" "eql" "logxor" nil nil nil ; 0x90
   nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil     ; 0xa0
   nil nil nil nil nil nil nil nil
   "set-current-buffer" "swap-buffer" "current-buffer" "bufferp" "markp" "windowp" "swap-window" nil
   nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil     ; 0xc0
   nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil     ; 0xd0
   nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil     ; 0xe0
   nil nil nil nil nil nil nil nil
   nil nil nil nil nil nil nil nil     ; 0xf0
   nil nil nil "jmp\t%d" "jn\t%d" "jt\t%d" "jnp\t%d" "jtp\t%d" ])

;;;###autoload
(defun disassemble-fun (fun &optional stream)
  "Disassembles the byte code form which is the function value of FUN. If
STREAM is given all output goes to that stream."
  (interactive "aFunction to disassemble:")
  (when (symbolp fun)
    (setq fun (symbol-function fun)))
  (if (eq (car fun) 'macro)
      (setq fun (nthcdr 3 fun))
    (setq fun (nthcdr 2 fun)))
  (when (or (stringp (car fun)) (numberp (car fun)))
    ;; doc-string
    (setq fun (cdr fun)))
  (when (and (consp (car fun)) (eq (car (car fun)) 'interactive))
    ;; interactive decl
    (setq fun (cdr fun)))
  (disassemble (car fun)) stream)

;; Disassembles the FORM, output goes to STREAM
(defun disassemble (form &optional stream)
  (let
      ((code-string (nth 1 form))
       (consts (nth 2 form))
       (i 0)
       c arg op)
    (unless stream
      (setq stream standard-output))
    (while (setq c (aref code-string i))
      (format stream "\n%d:\t" i)
      (cond
       ((< c op-last-with-args)
    (setq op (logand c 0xf8))
    (cond
     ((< (logand c 0x07) 6)
      (setq arg (logand c 0x07)))
     ((= (logand c 0x07) 6)
      (setq i (1+ i)
        arg (aref code-string i)))
     (t
      (setq arg (logior (lsh (aref code-string (1+ i)) 8)
                (aref code-string (+ i 2)))
        i (+ i 2))))
    (cond
     ((= op op-call)
      (format stream "call\t#%d" arg))
     ((= op op-push)
      (let
          ((argobj (aref consts arg)))
        (if (and (consp argobj) (eq (car argobj) 'jade-byte-code))
        (progn
          (format stream "push\t[%d] %S\n<byte-code" arg argobj)
          (disassemble argobj stream)
          (write stream "\n>"))
          (format stream "push\t[%d] %S" arg (aref consts arg)))))
     ((= op op-vrefc)
      (format stream "vrefc\t[%d] %S" arg (aref consts arg)))
     ((= op op-vsetc)
      (format stream "vsetc\t[%d] %S" arg (aref consts arg)))
     ((= op op-list)
      (format stream "list\t#%d" arg))
     ((= op op-bind)
      (format stream "bind\t[%d] %S" arg (aref consts arg)))))
       ((> c op-last-before-jmps)
    (setq arg (logior (lsh (aref code-string (1+ i)) 8)
              (aref code-string (+ i 2)))
          op c
          i (+ i 2))
    (format stream (aref dis-opcode-vector op) arg))
       (t
    (if (setq op (aref dis-opcode-vector c))
        (write stream op)
      (format stream "<unknown opcode %d>" c))))
      (setq i (1+ i)))
    t))